home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Yerk 3.6.7 / yerk 367 / tool+ / popUp6 < prev    next >
Text File  |  1994-11-29  |  6KB  |  155 lines
  1. \ pmenu knows how to popup when asked, and it keeps track of
  2. \    which item was selected, and it allows for an x,y offset
  3. \    for display purposes
  4.  
  5. :CLASS pmenu <super hmenu
  6.  
  7.     int        type        \ 0: 'offset' rel to mouse;1: use 'offset' as absolute
  8.     point    offset        \ if type=0, then MOUSE will be offset from upper left
  9.                         \  corner of menu.
  10.     int        lastPick    \ refers to item number (starting from 1)
  11.  
  12. \ determines if popup appears offset to mouse, or at absolute position
  13.   :M type: ( n --) put: type ;M
  14.  
  15.   :M popup: ( -- )
  16.     0 get: mHndl
  17.     get: type
  18.     IF   int: offset l->g intSwap
  19.     ELSE where: fevent unpack gety: offset - swap getx: offset - pack
  20.     THEN
  21.     int: lastpick   call popupmenuselect
  22.     unpack  -> menuId  -> mitem
  23.     mitem 0 >
  24.     IF get: resid menuId =                            \ is mouse in popUp?
  25.        IF   mitem put: lastPick mitem exec: self    \ yes
  26.        ELSE mitem menuId exec: menubar                \ must be hierarchical submenu
  27.        THEN 
  28.     ELSE 0 -> menuid
  29.     THEN ;M
  30.  
  31. \ this is coded to allow for getting the text item of a hierarchical menu
  32. \ attached to the popup
  33.   :M getText: ( item# -- addr len)
  34.         0 menuId makeInt call getMHandle            \ get menuhandle
  35.         swap makeint buf255 +base call GetItem    \ get text of selected item
  36.         buf255 count ;M
  37.  
  38.   :M offset: ( x y -- ) put: offset ;M
  39. \  :M position: ( x y -- ) put: self ;M
  40.  
  41.   :M putitem: ( lastPick -- ) put: lastPick ;M
  42.   :M getitem: ( -- lastPick ) get: lastPick ;M
  43.   :M getHItemName: ( -- addr len) get: lastPick getText: self ;M
  44.  
  45. \ inits to relative offset to mouse
  46.   :M classinit: 25 9 offset: self classinit: super ;M
  47.  
  48. ;CLASS
  49.  
  50.  
  51. \ stringvar - class of strings which are kept in memory
  52. \             as barrays and have a max length - from mh
  53. \ 5.24.89    rfl    twidth and type replaces stringwidth and drawstring
  54. \                 inset rect before print and changed 2 to 1 in justification
  55. \ 12.4.89    rfl a few modifications cosmetic
  56. \ 5.24.90    rfl    redid justinbox stuff to shorten code
  57. \ 7.12.92    rfl    deleted stringvar class
  58. \ 5.20.93    rfl    removed cursor stuff
  59. \ 8.4.93    rfl    mitem now points to text (from 1 not zero)...compatible with new pMenu fix. PROPOGATES
  60. \ 10.20.93    rfl    fixed exec: to not exec if no item was selected
  61. \  3.3.94    rfl    set: window for print: also
  62. \  4.26.94    rfl    uncommented in firstName:
  63.  
  64. \ Bitmap class for drawing bitmaps to screen
  65. :CLASS bMap  <Super warray
  66.  
  67.     Var        BaseAddr
  68.     Int        RowBytes
  69.     Rect    BndsRect
  70.     rect    DestRect
  71.  
  72.     \ (  n  l t r b -- )
  73.     :M  INIT:   Put:  bndsRect  Put: RowBytes  ;M
  74.  
  75.     :M putDest: { x y \ x0 y0 -- } size: BndsRect -> y0 -> x0
  76.             x y x0 x + y0 y + put: destRect ;M
  77.  
  78.     :M draw: idxbase +base Put: BaseAddr
  79.             abs: self portBit: actw
  80.             abs: BndsRect abs: destRect
  81.             word0 0 call copyBits ;M
  82.  
  83.     :M offset: ( dx dy -- ) offset: destrect ;M
  84.  
  85.     :M moveto: ( x y -- ) putDest: self draw: self ;M
  86.  
  87. ;CLASS
  88.  
  89. 5 bmap darrow    \ instantiate a global down pointing arrow
  90. hex
  91. $ ff80 $ 7f00 $ 3e00 $ 1c00 $ 0800  put: darrow
  92. decimal
  93. 2 0 0 9 5 init: darrow
  94.  
  95. \ draw text string justified in a given rectangle
  96. : ctextbox { addr len arect just -- }
  97.         addr +base len aRect +base just makeint call textbox ;
  98.  
  99. \ definition of class that handles popup menus
  100.  
  101. \ popupRect provides a way to use pmenu
  102. \    two kinds of disp/print are supported:
  103. \        display a fixed name string or
  104. \        display the last selected item in menu
  105.  
  106. :CLASS popUpMenu <super pMenu
  107.     int            dmode        \ display mode: ITEM (0) or NAME (1)
  108.     var            myAction    \ Menu has an action independent of item handler
  109.     var            myWindow    \ owning window
  110. 33    bytes        name        \ string holds name of rect...limited to 32 characters
  111.     int         txFont      \ retains its type of font
  112.     int         txSize
  113.     int         txFace
  114.     int            txJust        \ justification left(0), center(1), right(-1)
  115.     rect        myBorder    \ rectangle framing menu
  116.  
  117.   :M placeDarrow: getBotX: myBorder
  118.         13 - size: myBorder swap drop 2/ getTopY: myBorder + 2- putDest: darrow ;M
  119.  
  120. \ *** initializing methods ***
  121.   :M font: ( font size face -- ) put: txFace put: txSize put: txFont ;M
  122.   :M justify: put: txJust ;M
  123.   :M actions: put: myAction ;M
  124.   :M putWindow: put: myWindow ;M
  125.   :M setMode: ( displayMode -- ) put: dmode ;M
  126.   :M putRect: ( l t r b -- ) put: myBorder placeDarrow: self
  127.         getTop: myBorder offset: self ;M
  128.  
  129.   :M initFont: pushPort set: [ obj: myWindow ]
  130.         get: txFont tfont get: txSize tsize get: txFace tface popPort ;M
  131.  
  132.   :M getRect: ( -- topx topy botx boty ) get: myBorder ;M
  133.  
  134.   :M name: ( addr len -- ) dup 32 > classerr" 133 addr: name >str255 drop ;M
  135.  
  136.   :M getName: ( -- addr len ) addr: name count ;M
  137.  
  138.   :M print: ( -- ) pushPort actw obj: myWindow -> actw set: actw
  139.         2 1 inset: myBorder getBotX: myBorder dup 10 - putBotX: myBorder
  140.         1 tmode initFont: self
  141.         getName: self addr: myBorder get: txJust ctextBox 
  142.         putBotX: myBorder -2 -1 inset: myBorder  placeDarrow: self draw: darrow
  143.         -> actw popPort ;M
  144.  
  145.   :M draw: ( -- ) pushPort set: [ obj: myWindow ]
  146.         1 1 offset: myBorder draw: myBorder
  147.         -1 -1 offset: myBorder clear: myBorder draw: myBorder print: self popPort ;M
  148.  
  149.   :M ptIn: ( point --) ptIn: myBorder ;M
  150.  
  151.   :M exec: ( -- ) where: theMouse pack ptin: self
  152.         IF popup: self
  153.             mitem 0>        \ don't do anything if no item selected
  154.             IF get: dmode 0=
  155.                 I